home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / str-class.lsp < prev    next >
Lisp/Scheme  |  1992-07-29  |  15KB  |  344 lines
  1. ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. (defmethod initialize-internal-slot-functions :after
  31.           ((slotd structure-effective-slot-definition))
  32.   (let ((name (slot-definition-name slotd)))
  33.     (initialize-internal-slot-reader-gfs name)
  34.     (initialize-internal-slot-writer-gfs name)
  35.     (initialize-internal-slot-boundp-gfs name)))
  36.  
  37. (defmethod slot-definition-allocation ((slotd structure-slot-definition))
  38.   :instance)
  39.  
  40. (defmethod class-prototype ((class structure-class))
  41.   (with-slots (prototype) class
  42.     (or prototype
  43.         (setq prototype (make-class-prototype class)))))
  44.  
  45. (defmethod make-class-prototype ((class structure-class))
  46.   (with-slots (wrapper defstruct-constructor) class
  47.     (if defstruct-constructor
  48.         (make-instance class)
  49.       (let* ((proto (%allocate-instance--class *empty-vector*)))
  50.          (shared-initialize proto T :check-initargs-legality-p NIL)
  51.          (setf (std-instance-wrapper proto) wrapper)
  52.          proto))))
  53.  
  54.  
  55. (defmethod make-direct-slotd ((class structure-class)
  56.                               &rest initargs
  57.                               &key
  58.                               (name (error "Slot needs a name."))
  59.                               (conc-name (class-defstruct-conc-name class))
  60.                               (defstruct-accessor-symbol () acc-sym-p)
  61.                               &allow-other-keys)
  62.   (declare (ignore defstruct-accessor-symbol))
  63.   (declare (type symbol        name)
  64.            (type simple-string conc-name))
  65.   (let ((initargs (list* :class class :allow-other-keys T initargs)))
  66.     (unless acc-sym-p
  67.       (setf initargs
  68.             (list* :defstruct-accessor-symbol
  69.                    (intern (concatenate 'simple-string conc-name (symbol-name name))
  70.                            (symbol-package (class-name class)))
  71.                    initargs)))
  72.     (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
  73.  
  74. (defun slot-definition-defstruct-slot-description (slot)
  75.   (let ((type (slot-definition-type slot)))
  76.     `(,(slot-definition-name slot) ,(slot-definition-initform slot)
  77.       ,@(unless (eq type t) `(:type ,type)))))
  78.  
  79. (defmethod shared-initialize :after 
  80.       ((class structure-class)
  81.        slot-names
  82.        &key (direct-superclasses nil direct-superclasses-p)
  83.             (direct-slots nil direct-slots-p)
  84.             direct-default-initargs
  85.             (predicate-name   nil predicate-name-p))
  86.   (declare (ignore slot-names direct-default-initargs))
  87.   (let* ((name (class-name class))
  88.          (from-defclass-p (slot-value class 'from-defclass-p))
  89.          (defstruct-form (defstruct-form name))
  90.          (conc-name
  91.            (or (if defstruct-form (defstruct-form-conc-name defstruct-form))
  92.                (slot-value class 'defstruct-conc-name)
  93.                (format nil #-excl "~s structure class "
  94.                            #+excl "~s_STRUCTURE.CLASS_"
  95.                            name)))
  96.          (defstruct-predicate
  97.            (if defstruct-form (defstruct-form-predicate-name defstruct-form)))
  98.          (pred-name  ;; Predicate name for class
  99.            (or (if predicate-name-p (car predicate-name))
  100.                (if defstruct-form defstruct-predicate)
  101.                (slot-value class 'predicate-name)
  102.                (make-class-predicate-name name)))
  103.          (constructor
  104.            (or (if defstruct-form (defstruct-form-constructor defstruct-form))
  105.                (slot-value class 'defstruct-constructor)
  106.                (if from-defclass-p
  107.                    (list (intern (format nil "~aconstructor" conc-name)
  108.                                  (symbol-package name))
  109.                          ())))))
  110.     (declare (type symbol        name defstruct-predicate pred-name)
  111.              (type boolean       from-defclass-p)
  112.              (type simple-string conc-name))
  113.     (if direct-superclasses-p
  114.         (setf (slot-value class 'direct-superclasses)
  115.           (or direct-superclasses
  116.           (setq direct-superclasses
  117.                         (if (eq name 'structure-object)
  118.                             nil
  119.                 (list *the-class-structure-object*)))))
  120.         (setq direct-superclasses (slot-value class 'direct-superclasses)))
  121.     (setq direct-slots
  122.           (if direct-slots-p
  123.           (setf (slot-value class 'direct-slots)
  124.             (mapcar #'(lambda (pl)
  125.                                 (apply #'make-direct-slotd class
  126.                                         :conc-name conc-name pl))
  127.                 direct-slots))
  128.           (slot-value class 'direct-slots)))
  129.     (when from-defclass-p
  130.       (do-defstruct-from-defclass
  131.         class direct-superclasses direct-slots conc-name pred-name constructor))
  132.     (compile-structure-class-internals
  133.         class direct-slots conc-name pred-name constructor)
  134.     (setf (slot-value class 'predicate-name) pred-name)
  135.     (setf (slot-value class 'defstruct-conc-name) conc-name)
  136.     (unless (extract-required-parameters (second constructor))
  137.       (setf (slot-value class 'defstruct-constructor) (car constructor)))
  138.     (when (and defstruct-predicate (not from-defclass-p))
  139.       (setf (symbol-function pred-name) (symbol-function defstruct-predicate)))
  140.     (unless (or from-defclass-p (slot-value class 'documentation))
  141.       (setf (slot-value class 'documentation)
  142.             (format nil "~S structure class made from Defstruct" name)))
  143.     (setf (find-class name) class)
  144.     (update-structure-class class direct-superclasses direct-slots)))
  145.  
  146. (defun update-structure-class (class direct-superclasses direct-slots)
  147.   (add-direct-subclasses class direct-superclasses)
  148.   (let ((cpl (compute-class-precedence-list class)))
  149.     (setf (slot-value class 'class-precedence-list) cpl)
  150.     (let* ((eslotds (compute-slots class))
  151.            (internal-slotds (mapcar #'slot-definition-internal-slotd eslotds)))
  152.       (setf (slot-value class 'slots) eslotds)
  153.       (setf (slot-value class 'internal-slotds) internal-slotds)
  154.       (setf (slot-value class 'side-effect-internal-slotds) internal-slotds))
  155.     (if (slot-value class 'wrapper)
  156.         (setf (wrapper-class-precedence-list (slot-value class 'wrapper)) cpl)
  157.         (progn
  158.           (setf (slot-value class 'finalized-p) T)
  159.           (setf (slot-value class 'wrapper) (make-wrapper class))))
  160.     (unless (slot-boundp class 'prototype)
  161.       (setf (slot-value class 'prototype) nil))
  162.     (setf (slot-value class 'default-initargs) nil))
  163.   (add-slot-accessors class direct-slots))
  164.  
  165. (defmethod do-defstruct-from-defclass ((class structure-class)
  166.                                        direct-superclasses direct-slots
  167.                                        conc-name predicate constructor)
  168.   (declare (type simple-string conc-name))
  169.   (let* ((name (class-name class))
  170.          (original-defstruct-form
  171.           `(original-defstruct
  172.               (,name
  173.          ,@(when direct-superclasses
  174.            `((:include ,(class-name (car direct-superclasses)))))
  175.          (:print-function print-std-instance)
  176.          (:predicate ,predi